home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2tcU.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  4.0 KB  |  217 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b2tcU.c,v 1.4 85/08/22 16:57:11 timo Exp $
  5. */
  6.  
  7. /* unification of polytypes */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #include "b2tcP.h"
  12. #include "b2tcU.h"
  13. #include "b2tcE.h"
  14.  
  15. Hidden bool bad;
  16. Hidden bool cycling;
  17. Hidden bool badcycle;
  18.  
  19. Visible Procedure unify(a, b, pu)
  20. polytype a, b, *pu;
  21. {
  22.     bad = No;
  23.     cycling = No;
  24.     setreprtable();
  25.     u_unify(a, b, pu);
  26.     if (bad) badtyperr(a, b);
  27.     delreprtable();
  28. }
  29.  
  30. Hidden Procedure u_unify(a, b, pu)
  31. polytype a, b, *pu;
  32. {
  33.     typekind a_kind, b_kind;
  34.     polytype res;
  35.     
  36.     a_kind = kind(a);
  37.     b_kind = kind(b);
  38.     
  39.     if (are_same_types(a, b)) {
  40.         *pu = p_copy(a);
  41.     }
  42.     else if (t_is_var(a_kind) || t_is_var(b_kind)) {
  43.         substitute_for(a, b, pu);
  44.     }
  45.     else if (have_same_structure(a, b)) {
  46.         unify_subtypes(a, b, pu);
  47.     }
  48.     else if (has_number(a_kind) && has_number(b_kind)) {
  49.         *pu = mkt_number();
  50.     }
  51.     else if (has_text(a_kind) && has_text(b_kind)) {
  52.         *pu = mkt_text();
  53.     }
  54.     else if (has_text(a_kind) && t_is_tlt(b_kind)) {
  55.         u_unify(asctype(b), (res = mkt_text()), pu);
  56.         p_release(res);
  57.     }
  58.     else if (has_text(b_kind) && t_is_tlt(a_kind)) {
  59.         u_unify(asctype(a), (res = mkt_text()), pu);
  60.         p_release(res);
  61.     }
  62.     else if ((t_is_list(a_kind) && has_lt(b_kind))
  63.          ||
  64.          (t_is_list(b_kind) && has_lt(a_kind))
  65.     )
  66.     {
  67.         u_unify(asctype(a), asctype(b), &res);
  68.         *pu = mkt_list(res);
  69.     }
  70.     else if (t_is_table(a_kind) && has_lt(b_kind)) {
  71.         u_unify(asctype(a), asctype(b), &res);
  72.         *pu = mkt_table(p_copy(keytype(a)), res);
  73.     }
  74.     else if (t_is_table(b_kind) && has_lt(a_kind)) {
  75.         u_unify(asctype(a), asctype(b), &res);
  76.         *pu = mkt_table(p_copy(keytype(b)), res);
  77.     }
  78.     else if ((t_is_tlt(a_kind) && t_is_lt(b_kind))
  79.          || 
  80.          (t_is_lt(a_kind) && t_is_tlt(b_kind)))
  81.     {
  82.         u_unify(asctype(a), asctype(b), &res);
  83.         *pu = mkt_lt(res);
  84.     }
  85.     else if (t_is_error(a_kind) || t_is_error(b_kind)) {
  86.         *pu = mkt_error();
  87.     }
  88.     else {
  89.         *pu = mkt_error();
  90.         if (cycling)
  91.             badcycle = Yes;
  92.         else
  93.             bad = Yes;
  94.     }
  95. }
  96.  
  97. Hidden Procedure unify_subtypes(a, b, pu)
  98. polytype a, b, *pu;
  99. {
  100.     polytype sa, sb, s;
  101.     intlet nsub, is;
  102.     
  103.     nsub = nsubtypes(a);
  104.     *pu = mkt_polytype(kind(a), nsub);
  105.     for (is = 0; is < nsub; is++) {
  106.         sa = subtype(a, is);
  107.         sb = subtype(b, is);
  108.         u_unify(sa, sb, &s);
  109.         putsubtype(s, *pu, is);
  110.     }
  111. }
  112.  
  113. Forward bool contains();
  114. Forward bool equal_vars();
  115.  
  116. Hidden Procedure substitute_for(a, b, pu)
  117. polytype a, b, *pu;
  118. {
  119.     typekind a_kind, b_kind;
  120.     polytype ta, tb;
  121.     bool ta_is_a, tb_is_b;
  122.     
  123.     a_kind = kind(a);
  124.     b_kind = kind(b);
  125.     
  126.     if (t_is_var(a_kind) && table_has_type_of(a)) {
  127.         ta = type_of(a);
  128.         ta_is_a = No;
  129.     }
  130.     else {
  131.         ta = a;
  132.         ta_is_a = Yes;
  133.     }
  134.     if (t_is_var(b_kind) && table_has_type_of(b)) {
  135.         tb = type_of(b);
  136.         tb_is_b = No;
  137.     }
  138.     else {
  139.         tb = b;
  140.         tb_is_b = Yes;
  141.     }
  142.     
  143.     if (!(ta_is_a && tb_is_b))
  144.         u_unify(ta, tb, pu);
  145.     else if (!t_is_var(a_kind))
  146.         *pu = p_copy(a);
  147.     else
  148.         *pu = p_copy(b);
  149.     
  150.     if (t_is_var(a_kind)) {
  151.         if (contains(*pu, bottom_var(a)))
  152.             textify(a, pu);
  153.     }
  154.     if (t_is_var(b_kind)) {
  155.         if (contains(*pu, bottom_var(b)))
  156.             textify(b, pu);
  157.     }
  158.     
  159.     if (t_is_var(a_kind) && !are_same_types(*pu, a))
  160.         repl_type_of(a, *pu);
  161.     if (t_is_var(b_kind) && !are_same_types(*pu, b))
  162.         repl_type_of(b, *pu);
  163. }
  164.  
  165. Hidden Procedure textify(a, pu)
  166. polytype a, *pu;
  167. {
  168.     polytype ttext, text_hopefully;
  169.     
  170.     ttext = mkt_text();
  171.     cycling = Yes;
  172.     badcycle = No;
  173.     u_unify(*pu, ttext, &text_hopefully);
  174.     if (badcycle EQ No) {
  175.         p_release(text_hopefully);
  176.         u_unify(a, ttext, &text_hopefully);
  177.     }
  178.     if (badcycle EQ No) {
  179.         *pu = ttext;
  180.     }
  181.     else {
  182.         *pu = mkt_error();
  183.         cyctyperr(a);
  184.         p_release(ttext);
  185.     }
  186.     p_release(text_hopefully);
  187.     cycling = No;
  188. }
  189.  
  190. Visible bool contains(u, a) polytype u, a; {
  191.     bool result;
  192.     
  193.     result = No;
  194.     if (t_is_var(kind(u))) {
  195.         if (table_has_type_of(u)) {
  196.             result = contains(type_of(u), a);
  197.         }
  198.     }
  199.     else {
  200.         polytype s;
  201.         intlet is, nsub;
  202.         nsub = nsubtypes(u);
  203.         for (is = 0; is < nsub; is++) {
  204.             s = subtype(u, is);
  205.             if (equal_vars(s, a) || contains(s, a)) {
  206.                 result = Yes;
  207.                 break;
  208.             }
  209.         }
  210.     }
  211.     return (result);
  212. }
  213.  
  214. Visible bool equal_vars(s, a) polytype s, a; {
  215.     return (are_same_types(bottom_var(s), a));
  216. }
  217.